home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / ANALYSIS.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  7.7 KB  |  272 lines
  1. ; ANALYSIS.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Closure Analysis and Heap Allocation            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ;  Pass 1
  23. ;
  24. ;     Mark lambda expressions to be closed (LAMBDA-CLOSED?=T) at the point
  25. ;     of definition whenever any of the following occur:
  26. ;
  27. ;    -- the identifier bound to the lambda expression is used as a
  28. ;       funarg                    [p1-id]
  29. ;
  30. ;    -- the lambda expression is itself used as a funarg
  31. ;                            [p1-lambda]
  32. ;
  33. ;    -- the identifier bound to the lambda expression is modified
  34. ;       by SET!                    [p1-set!]
  35. ;
  36. ;    -- the expression is a MULAMBDA            [p1-lambda]
  37. ;
  38. ;     Mark all identifiers which are bound to closures by LETREC:
  39. ;
  40. ;    -- ID-INIT: the lambda expression the ID was bound to
  41. ;       (else it is NIL)                [p1-lambda]
  42. ;
  43. ;  Pass 2
  44. ;
  45. ;     Determine which variables must be heap-allocated by gathering the
  46. ;     following facts used later:
  47. ;
  48. ;    -- ID-SET!?: it is modified by a SET!        [p2-set!]
  49. ;
  50. ;    -- ID-FREEREF?: it is freely referenced by some function
  51. ;
  52. ;    -- ID-FUNARGSEES?: it is "visible" to a closed function
  53. ;
  54. ;     We do not compute the transitive closure of functions reachable from
  55. ;     closed functions.  Instead, we consider an ID to be funargref'd if
  56. ;     (1) ID is freely referenced from SOME function AND (2) ID is visible,
  57. ;     though not necessarily referenced, from a closed function.
  58. ;
  59. ;     An ID will be heap-allocated if it is potentially referenced from a
  60. ;     funarg (both ID-FREEREF? and ID-FUNARGSEES? set non-nil) and must
  61. ;     exist at runtime.  It exists at runtime if it is modified (ID-SET!?),
  62. ;     or is initialized to some value other than a lambda expression
  63. ;     (ID-INIT=NIL), or the lambda expression it is bound to is closed.
  64. ;
  65.  
  66. (define pcs-closure-analysis
  67.   (lambda (exp)
  68.     (letrec
  69. ;----!
  70.      (
  71.   (p1-exp
  72.    (lambda (x)
  73.      (case (car x)
  74.        (quote            '())
  75.        (#!TOKEN             (p1-id x))
  76.        (lambda           (p1-lambda x))
  77.        (set!             (p1-set! x))
  78.    ;;  (if               (p1-args (cdr x)))    treat as a primop
  79.    ;;  (begin            (p1-args (cdr x)))    treat as a primop
  80.        (letrec           (p1-letrec x))
  81.        (else             (p1-application x))
  82.        )))
  83.  
  84.   (p1-id
  85.    (lambda (id)
  86.      (close-funarg (id-init id))))
  87.  
  88.   (p1-set!
  89.    (lambda (x)
  90.      (p1-id (set!-id x))
  91.      (p1-exp (set!-exp x))))
  92.  
  93.   (p1-lambda
  94.    (lambda (x)
  95.      (create-lambda-label x '())
  96.      (close-funarg x)
  97.      (p1-exp (lambda-body x))))
  98.  
  99.   (p1-letrec
  100.    (lambda (x)
  101.      (let ((pairs (letrec-pairs x)))
  102.        (p1-pairs-1 pairs)            ; link up lambda's and id's
  103.        (p1-pairs-2 pairs)            ; find funargref's to id's
  104.        (p1-exp (letrec-body x)))))
  105.  
  106.   (p1-pairs-1
  107.    (lambda (pairs)
  108.      (when pairs
  109.        (let* ((pr  (car pairs))
  110.           (id  (car pr))
  111.           (exp (cadr pr)))
  112.          (when (eq? (car exp) 'lambda)
  113.            (create-lambda-label exp id)
  114.            (set-id-init id exp)
  115.            (when (negative? (lambda-nargs exp))
  116.              (close-funarg exp)))
  117.          (p1-pairs-1 (cdr pairs))))))
  118.  
  119.   (p1-pairs-2
  120.    (lambda (pairs)
  121.      (when pairs
  122.        (let* ((pr  (car pairs))
  123.           (id  (car pr))
  124.           (exp (cadr pr)))
  125.          (if (eq? (car exp) 'lambda)
  126.          (p1-exp (lambda-body exp))
  127.          (p1-exp exp))
  128.          (p1-pairs-2 (cdr pairs))))))
  129.  
  130.   (p1-application
  131.    (lambda (x)
  132.      (let ((fn (car x))
  133.        (args (cdr x)))
  134.        (p1-args args)
  135.        (cond ((or (atom? fn)
  136.           (eq? (car fn) '#!TOKEN))
  137.           '())
  138.          ((eq? (car fn) 'LAMBDA)
  139.           (p1-exp (lambda-body fn)))
  140.          (else
  141.           (p1-exp fn))))))
  142.  
  143.   (p1-args
  144.    (lambda (args)
  145.      (when args
  146.        (p1-exp (car args))
  147.        (p1-args (cdr args)))))
  148.  
  149.   (close-funarg
  150.    (lambda (fn)
  151.      (when fn
  152.        (set-lambda-closed? fn #T))))
  153.  
  154.   (create-lambda-label
  155.    (lambda (fn id)
  156.      (set-lambda-label fn
  157.        (if (null? id)
  158.            (pcs-make-label 'lambda)
  159.            (cons (id-number id) (id-name id))))))
  160.  
  161.   ;;                         ------ pass 2 -------
  162.  
  163.   (p2-exp
  164.    (lambda (x env locals)
  165.      (case (car x)
  166.        (quote            '())
  167.        (#!TOKEN             (p2-id x env locals))
  168.        (lambda           (p2-lambda x env locals))
  169.        (set!             (p2-set! x env locals))
  170.    ;;  (if               (p2-args (cdr x) env locals))    treat as a primop
  171.    ;;  (begin            (p2-args (cdr x) env locals))    treat as a primop
  172.        (letrec           (p2-letrec x env locals))
  173.        (else             (p2-application x env locals))
  174.        )))
  175.  
  176.   (p2-id
  177.    (lambda (id env locals)
  178.      (when (not (memq id locals))
  179.        (set-id-freeref? id #T))))
  180.  
  181.   (p2-set!
  182.    (lambda (x env locals)
  183.      (let ((id (set!-id x))
  184.        (val (set!-exp x)))
  185.        (set-id-set!? id #T)
  186.        (p2-id id env locals)
  187.        (p2-exp val env locals))))
  188.  
  189.   (p2-lambda
  190.    (lambda (x env locals)
  191.      (let ((bvl (lambda-bvl x)))
  192.        (when (lambda-closed? x)
  193.          (do ((env env (cdr env)))
  194.          ((null? env))
  195.            (do ((rib (car env)(cdr rib)))
  196.            ((null? rib))
  197.          (set-id-funargsees? (car rib) #T))))
  198.        (p2-exp (lambda-body x)
  199.            (cons bvl env)
  200.            bvl))))
  201.  
  202.   (p2-letrec
  203.    (lambda (x env locals)
  204.      (let* ((pairs  (letrec-pairs x))
  205.         (bvl    (mapcar car pairs))
  206.         (body   (letrec-body x))
  207.         (env    (cons bvl env))
  208.         (locals (append bvl locals)))
  209.        (p2-pairs pairs env locals)
  210.        (p2-exp body env locals))))
  211.   
  212.   (p2-pairs
  213.    (lambda (pairs env locals)
  214.      (when pairs
  215.        (p2-exp (cadr (car pairs)) env locals)
  216.        (p2-pairs (cdr pairs) env locals))))
  217.  
  218.   ;; p2-application must process IDs in function position
  219.   ;; because they may need to be heap allocated; e.g:
  220.   ;; (lambda (f)
  221.   ;;   (lambda (x)   ; 'f' must be heap allocated
  222.   ;;     (f x)))     ; 'f' appears only in function position
  223.  
  224.   (p2-application
  225.    (lambda (x env locals)
  226.      (let ((fn (car x)))
  227.        (if (or (eq? fn 'THE-ENVIRONMENT)
  228.            (eq? fn '%MAKE-HASHED-ENVIRONMENT))
  229.        (smash-the-environment #T env)
  230.        (let ((args (cdr x)))
  231.          (when (eq? fn '%CALL/CC)
  232.            (smash-the-environment #F env))
  233.          (p2-args args env locals)
  234.          (when (pair? fn)
  235.            (if (eq? (car fn) 'LAMBDA)
  236.                (p2-exp (lambda-body fn)
  237.                    (cons (lambda-bvl fn) env)
  238.                    (lambda-bvl fn))
  239.                (p2-exp fn env locals))))))))
  240.  
  241.   ;; (THE-ENVIRONMENT) requires all visible lexical variables
  242.   ;; to be heap-allocated
  243.  
  244.   (smash-the-environment
  245.    (lambda (smash-all? env)
  246.      (when env
  247.        (do ((rib (car env)              ; CDR down this rib
  248.              (cdr rib)))
  249.            ((null? rib))
  250.          (let ((id (car rib))
  251.            (yes #T))
  252.            (set-id-funargsees? id yes)
  253.            (set-id-freeref? id yes)
  254.            (when smash-all?
  255.              (set-id-set!? id yes)
  256.              (close-funarg (id-init id)))))
  257.        (smash-the-environment smash-all? (cdr env)))))   ; get the next rib
  258.  
  259.   (p2-args
  260.    (lambda (args env locals)
  261.      (when args
  262.        (p2-exp (car args) env locals)
  263.        (p2-args (cdr args) env locals))))
  264.  
  265. ;----!
  266.      )
  267.    (begin
  268.       (p1-exp exp)
  269.       (p2-exp exp '() '())
  270.       '()))))   ; executed for effect only
  271.  
  272.